;; test-tokenize.scm: lexer test routines for r6rs-thrift
;; Copyright (C) 2012 Julian Graham

;; r6rs-thrift is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

#!r6rs

(import (rnrs))
(import (srfi :64))
(import (thrift compile tokenize))

; (set! test-log-to-file #f)

(define (token-map str f)
  (let loop ((lexer (thriftc:make-tokenizer (open-input-string str)))
	     (lst '()))
    (let ((tok (lexer)))
      (if (eq? tok '*eoi*) 
	  (reverse lst) 
	  (loop lexer (cons (f tok) lst))))))

(define (token-categories str)
  (token-map str thriftc:lexical-token-category))
(define (token-pairs str)
  (token-map str (lambda (tok) (cons (thriftc:lexical-token-category tok) 
				     (thriftc:lexical-token-value tok)))))

(test-begin "thrift:tokenize")
(test-begin "simple")

(test-group "lparen" (test-equal '(LPAREN) (token-categories "(")))
(test-group "rparen" (test-equal '(RPAREN) (token-categories ")")))
(test-group "lbrack" (test-equal '(LBRACK) (token-categories "[")))
(test-group "rbrack" (test-equal '(RBRACK) (token-categories "]")))
(test-group "lbrace" (test-equal '(LBRACE) (token-categories "{")))
(test-group "rbrace" (test-equal '(RBRACE) (token-categories "}")))
(test-group "langle" (test-equal '(LANGLE) (token-categories "<")))
(test-group "rangle" (test-equal '(RANGLE) (token-categories ">")))
(test-group "equal" (test-equal '(EQUAL) (token-categories "=")))
(test-group "colon" (test-equal '(COLON) (token-categories ":")))
(test-group "semicolon" (test-equal '(SEMICOLON) (token-categories ";")))
(test-group "comma" (test-equal '(COMMA) (token-categories ",")))
(test-group "star" (test-equal '(STAR) (token-categories "*")))

(test-group "include" (test-equal '(INCLUDE) (token-categories "include")))
(test-group "namespace" 
	    (test-equal '(NAMESPACE) (token-categories "namespace")))
(test-group "const" (test-equal '(CONST) (token-categories "const")))
(test-group "typedef" (test-equal '(TYPEDEF) (token-categories "typedef")))
(test-group "struct" (test-equal '(STRUCT) (token-categories "struct")))
(test-group "union" (test-equal '(UNION) (token-categories "union")))
(test-group "exception" 
	    (test-equal '(EXCEPTION) (token-categories "exception")))
(test-group "extends" (test-equal '(EXTENDS) (token-categories "extends")))
(test-group "throws" (test-equal '(THROWS) (token-categories "throws")))
(test-group "service" (test-equal '(SERVICE) (token-categories "service")))
(test-group "oneway" (test-equal '(ONEWAY) (token-categories "oneway")))
(test-group "void" (test-equal '(VOID) (token-categories "void")))
(test-group "enum" (test-equal '(ENUM) (token-categories "enum")))
(test-group "true" (test-equal '(TRUE) (token-categories "true")))
(test-group "false" (test-equal '(FALSE) (token-categories "false")))
(test-group "required" (test-equal '(REQUIRED) (token-categories "required")))
(test-group "optional" (test-equal '(OPTIONAL) (token-categories "optional")))
(test-group "double" (test-equal '(DOUBLE) (token-categories "double")))
(test-group "i16" (test-equal '(I32) (token-categories "i32")))
(test-group "i32" (test-equal '(I32) (token-categories "i32")))
(test-group "i64" (test-equal '(I64) (token-categories "i64")))
(test-group "bool" (test-equal '(BOOL) (token-categories "bool")))
(test-group "string" (test-equal '(STRING) (token-categories "string")))
(test-group "binary" (test-equal '(BINARY) (token-categories "binary")))
(test-group "set" (test-equal '(SET) (token-categories "set")))
(test-group "map" (test-equal '(MAP) (token-categories "map")))
(test-group "list" (test-equal '(LIST) (token-categories "list")))

(test-end "simple")

(test-begin "identifiers")
(test-group "simple" (test-equal '((IDENTIFIER . "foo")) (token-pairs "foo")))
(test-group "complex" 
  (test-equal '((IDENTIFIER . "foo.bar")) (token-pairs "foo.bar")))
(test-end "identifiers")

(test-begin "literals")

(test-group "integers"
  (test-equal '((NUM-INTEGER . 123)) (token-pairs "123"))
  (test-equal '((NUM-INTEGER . -456)) (token-pairs "-456")))
(test-group "floats"
  (test-equal '((NUM-FLOAT . 1.23)) (token-pairs "1.23"))
  (test-equal '((NUM-FLOAT . -0.456)) (token-pairs "-0.456")))
(test-group "strings"
  (test-equal '((STRING-LITERAL . "test")) (token-pairs "\"test\""))
  (test-equal '((STRING-LITERAL . "test")) (token-pairs "'test'")))

(test-end "literals")

(test-begin "comments")
(test-equal '((STRING-LITERAL . "foo")) (token-pairs "\"foo\" // Comment"))
(test-equal '((STRING-LITERAL . "foo")) (token-pairs "\"foo\" # Comment"))
(test-equal '((STRING-LITERAL . "foo") (STRING-LITERAL . "bar")) 
	    (token-pairs "\"foo\" // Comment\n\"bar\""))
(test-equal '((STRING-LITERAL . "foo") (STRING-LITERAL . "bar"))
	    (token-pairs "\"foo\" /* Comment */ \"bar\""))
(test-end "comments")

(test-end "thrift:tokenize")
